home *** CD-ROM | disk | FTP | other *** search
/ Hardcore Visual Basic 5.0 (2nd Edition) / Hardcore Visual Basic 5.0 - Second Edition (1997)(Microsoft Press).iso / Code / LOCALM~1 / Draw.bas < prev    next >
BASIC Source File  |  1997-06-14  |  8KB  |  227 lines
  1. Attribute VB_Name = "MDraw"
  2. Option Explicit
  3.  
  4. Public Enum EErrorDraw
  5.     eeBaseDraw = 13460  ' Draw
  6. End Enum
  7.  
  8. Const PI = 3.1415
  9.  
  10. Sub BmpSpiral(cvsDst As Object, picSrc As Picture)
  11. With cvsDst
  12.     ' Calculate sizes
  13.     Dim dxSrc As Long, dySrc As Long, dxDst As Long, dyDst As Long
  14.     dxSrc = .ScaleX(picSrc.Width): dySrc = .ScaleY(picSrc.Height)
  15.     dxDst = .ScaleWidth: dyDst = .ScaleHeight
  16.     ' Set defaults (play with these numbers for different effects)
  17.     Dim xInc As Long, yInc As Long, xSize As Long, ySize As Long
  18.     Dim x As Long, y As Long
  19.     xInc = CInt(dxSrc * 0.01): yInc = CInt(dySrc * 0.01)
  20.     xSize = CInt(dxSrc * 0.1): ySize = CInt(dySrc * 0.1)
  21.     Dim radCur As Single, degCur As Integer, angInc As Integer
  22.     degCur = 0: angInc = 55
  23.     ' Start in center
  24.     x = (dxDst \ 2) - (dxSrc \ 2): y = (dyDst \ 2) - (dySrc \ 2)
  25.     
  26.     ' Spiral until off destination
  27.     Do
  28.         ' Draw at current position
  29.         .PaintPicture picSrc, x, y, , , , , , , vbSrcAnd
  30.         ' Calculate angle in radians
  31.         radCur = (degCur - 90) * (PI / 180)
  32.         ' Calculate next x and y
  33.         x = x + (xSize * Cos(radCur))
  34.         y = y + (ySize * Sin(radCur))
  35.         ' Widen spiral
  36.         xSize = xSize + xInc: ySize = ySize + yInc + 1
  37.         ' Turn angle
  38.         degCur = (degCur + angInc) Mod 360
  39.     Loop While (x > 0) And (x + dxSrc < dxDst - dxSrc) And _
  40.                (y > 0) And (y + dySrc < dyDst)
  41. End With
  42. End Sub
  43.  
  44. Sub SpiralBmp(cvsDst As Object, picSrc As Picture, _
  45.               ByVal xOff As Long, ByVal yOff As Long)
  46. With cvsDst
  47.     Dim xLeft As Long, xRight As Long, yTop As Long, yBottom As Long
  48.     Dim dxSrc As Long, dySrc As Long, xSrc As Long, ySrc As Long
  49.     Dim xDst As Long, yDst As Long, xInc As Long, yInc As Long
  50.     Dim x As Long, y As Long
  51.     ' Initialize
  52.     dxSrc = .ScaleX(picSrc.Width): dySrc = .ScaleY(picSrc.Height)
  53.     xInc = dxSrc / 20: yInc = dySrc / 20
  54.     xLeft = 0: yTop = 0:
  55.     xRight = dxSrc - xInc: yBottom = dySrc - yInc
  56.  
  57.     ' Draw each side
  58.     Do While (xLeft <= xRight) And (yTop <= yBottom)
  59.         ' Top
  60.         For x = xLeft To xRight Step xInc
  61.             .PaintPicture picSrc, x + xOff, y + yOff, xInc, yInc, _
  62.                 x, y, xInc, yInc, vbSrcCopy
  63.         Next
  64.         x = x - xInc: yTop = yTop + yInc
  65.         ' Right
  66.         For y = yTop To yBottom Step yInc
  67.             .PaintPicture picSrc, x + xOff, y + yOff, xInc, yInc, _
  68.                 x, y, xInc, yInc, vbSrcCopy
  69.         Next
  70.         y = y - yInc: xRight = x - xInc
  71.         ' Bottom
  72.         For x = xRight To xLeft Step -xInc
  73.             .PaintPicture picSrc, x + xOff, y + yOff, xInc, yInc, _
  74.                 x, y, xInc, yInc, vbSrcCopy
  75.         Next
  76.         x = x + xInc: yBottom = y - yInc
  77.         ' Left
  78.         For y = yBottom To yTop Step -yInc
  79.             .PaintPicture picSrc, x + xOff, y + yOff, xInc, yInc, _
  80.                 x, y, xInc, yInc, vbSrcCopy
  81.         Next
  82.         y = y + yInc: xLeft = xLeft + xInc
  83.     Loop
  84. End With
  85. End Sub
  86.  
  87. Sub BmpTile(cvsDst As Object, picSrc As Picture)
  88. With cvsDst
  89.     ' Calculate sizes
  90.     Dim dxSrc As Long, dySrc As Long, dxDst As Long, dyDst As Long
  91.     dxSrc = .ScaleX(picSrc.Width): dySrc = .ScaleY(picSrc.Height)
  92.     dxDst = .ScaleWidth: dyDst = .ScaleHeight
  93.     ' Tile until off destination
  94.     Dim x As Long, y As Long, fAutoRedraw As Boolean
  95.     fAutoRedraw = .AutoRedraw
  96.     .AutoRedraw = False
  97.     Do While y < dyDst
  98.         Do While x < dxDst
  99.             ' Draw at current position
  100.             .PaintPicture picSrc, x, y
  101.             x = x + dxSrc
  102.         Loop
  103.         y = y + dySrc
  104.         x = 0
  105.     Loop
  106.     .AutoRedraw = fAutoRedraw
  107. End With
  108. End Sub
  109.  
  110. Sub Star(cvsDst As Object, ByVal x As Long, ByVal y As Long, _
  111.          ByVal dxyRadius As Long, clrBorder As Long, _
  112.          Optional clrOut As Long = -1, Optional clrIn As Long = -1)
  113. With cvsDst
  114.     ' Handle optional arguments
  115.     If clrOut = -1 Then clrOut = clrBorder
  116.     If clrIn = -1 Then clrIn = clrOut
  117.     
  118.     ' Start is 144 degrees (converted to radians)
  119.     Const radStar As Double = 144 * PI / 180
  120.     
  121.     ' Calculate each point
  122.     Dim ptPoly(1 To 10) As Long, i As Integer
  123.     For i = 1 To 10 Step 2
  124.         ptPoly(i) = x + (Cos((i \ 2 + 1) * radStar) * dxyRadius)
  125.         ptPoly(i + 1) = y + (Sin((i \ 2 + 1) * radStar) * dxyRadius)
  126.     Next
  127.     
  128.     ' Set colors and style for star
  129.     .ForeColor = clrBorder    ' SetTextColor
  130.     .FillColor = clrOut       ' CreateSolidBrush
  131.     .FillStyle = vbSolid      ' More CreateSolidBrush
  132.     
  133.     Call MGDITool.VBPolygon(.hDC, ptPoly)
  134.     
  135.     ' Set color for center
  136.     .FillColor = clrIn        ' CreateSolidBrush
  137.     Call MGDITool.VBFloodFill(.hDC, x, y, .ForeColor)
  138. End With
  139. End Sub
  140.  
  141. Sub Fade(cvsDst As Object, _
  142.          Optional Red As Boolean = False, _
  143.          Optional Green As Boolean = False, _
  144.          Optional Blue As Boolean = True, _
  145.          Optional Vertical As Boolean = True, _
  146.          Optional Horizontal As Boolean = False, _
  147.          Optional LightToDark As Boolean = True)
  148. With cvsDst
  149.     ' Trap errors
  150.     On Error Resume Next
  151.     
  152.     ' Save properties
  153.     Dim fAutoRedraw As Boolean, ordDrawStyle As Integer
  154.     Dim ordDrawMode As Integer, iDrawWidth As Integer
  155.     Dim ordScaleMode As Integer
  156.     Dim rScaleWidth As Single, rScaleHeight As Single
  157.     fAutoRedraw = .AutoRedraw: iDrawWidth = .DrawWidth
  158.     ordDrawStyle = .DrawStyle: ordDrawMode = .DrawMode
  159.     rScaleWidth = .ScaleWidth: rScaleHeight = .ScaleHeight
  160.     ordScaleMode = .ScaleMode
  161.     ' Err set if object lacks one of previous properties
  162.     If Err Then Exit Sub
  163.     ' If you get here, object is OK (Printer lacks AutoRedraw)
  164.     fAutoRedraw = .AutoRedraw
  165.     
  166.     ' Set properties required for fade
  167.     .AutoRedraw = True
  168.     .DrawWidth = 3              ' Must be greater than 1 for dithering
  169.     .DrawStyle = vbInsideSolid  ' vbInvisible gives an interesting effect
  170.     .DrawMode = vbCopyPen       ' Try vbXorPen or vbMaskNotPen
  171.     .ScaleMode = vbPixels
  172.     .ScaleWidth = 256 * 2: .ScaleHeight = 256 * 2
  173.     
  174.     Dim clr As Long, i As Integer, x As Integer, y As Integer
  175.     Dim iRed As Integer, iGreen As Integer, iBlue As Integer
  176.     For i = 0 To 255
  177.         ' Set line color
  178.         If LightToDark Then
  179.             If Red Then iRed = 255 - i
  180.             If Blue Then iBlue = 255 - i
  181.             If Green Then iGreen = 255 - i
  182.         Else
  183.             If Red Then iRed = i
  184.             If Blue Then iBlue = i
  185.             If Green Then iGreen = i
  186.         End If
  187.         clr = RGB(iRed, iGreen, iBlue)
  188.         ' Draw each line of fade
  189.         If Vertical Then
  190.             cvsDst.Line (0, y)-(.ScaleWidth, y + 2), clr, BF
  191.             y = y + 2
  192.         End If
  193.         If Horizontal Then
  194.             cvsDst.Line (x, 0)-(x + 2, .ScaleHeight), clr, BF
  195.             x = x + 2
  196.         End If
  197.     Next
  198.     ' Put things back the way you found them
  199.     .AutoRedraw = fAutoRedraw: .DrawWidth = iDrawWidth
  200.     .DrawStyle = ordDrawStyle: .DrawMode = ordDrawMode
  201.     .ScaleMode = ordScaleMode
  202.     .ScaleWidth = rScaleWidth: .ScaleHeight = rScaleHeight
  203. End With
  204. End Sub
  205. '
  206.  
  207. #If fComponent = 0 Then
  208. Private Sub ErrRaise(e As Long)
  209.     Dim sText As String, sSource As String
  210.     If e > 1000 Then
  211.         sSource = App.ExeName & ".Draw"
  212.         Select Case e
  213.         Case eeBaseDraw
  214.             BugAssert True
  215.        ' Case ee...
  216.        '     Add additional errors
  217.         End Select
  218.         Err.Raise COMError(e), sSource, sText
  219.     Else
  220.         ' Raise standard Visual Basic error
  221.         sSource = App.ExeName & ".VBError"
  222.         Err.Raise e, sSource
  223.     End If
  224. End Sub
  225. #End If
  226.  
  227.